home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / language / ici / ici.cpi / array.c < prev    next >
C/C++ Source or Header  |  1994-10-27  |  5KB  |  286 lines
  1. #include "ptr.h"
  2. #include "exec.h"
  3. #include "op.h"
  4. #include "int.h"
  5. #include "buf.h"
  6.  
  7. int
  8. growarray(a, n)
  9. register array_t    *a;
  10. register int        n;
  11. {
  12.     register object_t    **e;
  13.  
  14.     if (objof(a)->o_flags & O_ATOM)
  15.     {
  16.     error = "attempt to write on constant array";
  17.     return 1;
  18.     }
  19.     if (a->a_base == NULL)
  20.     {
  21.     /*
  22.      * Virgin array, first memory allocation (only happens because
  23.      * of special case in ici_evaluate).
  24.      */
  25.     n += 4;
  26.     n *= sizeof(object_t *);
  27.     if ((e = (object_t **)zalloc(n)) == NULL)
  28.         return 1;
  29.     a->a_base = e;
  30.     a->a_top = e;
  31.     a->a_limit = e + n / sizeof(object_t *);
  32.     }
  33.     else
  34.     {
  35.     /*
  36.      * Append space to the array.  We don't use realloc to ensure
  37.      * that memory exhaustion is cleanly recovereable.
  38.      */
  39.     if ((a->a_limit - a->a_base) * 3 / 2 < a->a_limit - a->a_base + n)
  40.         n += (a->a_limit - a->a_base) + 10;
  41.     else
  42.         n = (a->a_limit - a->a_base) * 3 / 2;
  43.     n *= sizeof(object_t *);
  44.     if ((e = (object_t **)zalloc(n)) == NULL)
  45.         return 1;
  46.     memcpy((char *)e, (char *)a->a_base,
  47.         (a->a_limit - a->a_base) * sizeof(object_t *));
  48.     a->a_top = e + (a->a_top - a->a_base);
  49.     zfree((char *)a->a_base);
  50.     a->a_base = e;
  51.     a->a_limit = e + n / sizeof(object_t *);
  52.     }
  53.     return 0;
  54. }
  55.  
  56. int
  57. faultarray(a, i)
  58. register array_t    *a;
  59. register int        i;
  60. {
  61.     if (objof(a)->o_flags & O_ATOM)
  62.     {
  63.     error = "attempt to write on constant array";
  64.     return 1;
  65.     }
  66.     if (i < 0)
  67.     {
  68.     sprintf(buf, "attempt to write at array index %d\n", i);
  69.     error = buf;
  70.     return 1;
  71.     }
  72.     ++i;
  73.     i -= a->a_top - a->a_base;
  74.     if (pushcheck(a, i))
  75.     return 1;
  76.     while (--i >= 0)
  77.     *a->a_top++ = objof(&o_null);
  78.     return 0;
  79. }
  80.  
  81. int
  82. badindex()
  83. {
  84.     error = "array index range error";
  85.     return 1;
  86. }
  87.  
  88. /*
  89.  * Return a new array.  It will have room for at least 6 elements from
  90.  * the start.
  91.  */
  92. array_t *
  93. new_array()
  94. {
  95.     register array_t    *a;
  96.  
  97.     if ((a = talloc(array_t)) == NULL)
  98.     return NULL;
  99.     objof(a)->o_type = &array_type;
  100.     objof(a)->o_tcode = TC_ARRAY;
  101.     objof(a)->o_flags = 0;
  102.     objof(a)->o_nrefs = 1;
  103.     rego(a);
  104.     a->a_base = NULL;
  105.     a->a_top = NULL;
  106.     a->a_limit = NULL;
  107.     /*
  108.      * Note that the following FEW_OBJS is choosen to correspond with the
  109.      * size of the smaller special memory list.
  110.      */
  111.     if ((a->a_base = (object_t **)zalloc(FEW_OBJS*sizeof(object_t *))) == NULL)
  112.     return NULL;
  113.     a->a_top = a->a_base;
  114.     a->a_limit = a->a_base + FEW_OBJS;
  115.     return a;
  116. }
  117.  
  118. STATIC long
  119. mark_array(a)
  120. register array_t    *a;
  121. {
  122.     register object_t    **e;
  123.     long        mem;
  124.  
  125.     objof(a)->o_flags |= O_MARK;
  126.     mem = sizeof(array_t) + (a->a_limit - a->a_base) * sizeof(object_t *);
  127.     for (e = a->a_base; e < a->a_top; ++e)
  128.     mem += mark(*e);
  129.     return mem;
  130. }
  131.  
  132. void
  133. free_array(a)
  134. register array_t    *a;
  135. {
  136.     if (a->a_base != NULL)
  137.     zfree((char *)a->a_base);
  138.     /*
  139.      * This special guard is only needed for arrays because the execution
  140.      * loop uses static arrays which get their memory freed by this
  141.      * routine, but don't have allocated bodies.
  142.      */
  143.     if (objof(a)->o_nrefs == 0)
  144.     zfree((char *)a);
  145. }
  146.  
  147. STATIC int
  148. cmp_array(a1, a2)
  149. array_t    *a1;
  150. array_t    *a2;
  151. {
  152.     register int    i;
  153.  
  154.     if (a1 == a2)
  155.     return 0;
  156.     if ((i = a1->a_top - a1->a_base) != a2->a_top - a2->a_base)
  157.     return 1;
  158.     return memcmp((char *)a1->a_base, (char *)a2->a_base,
  159.             i * sizeof(object_t *));
  160. }
  161.  
  162. STATIC object_t *
  163. copy_array(a)
  164. register array_t    *a;
  165. {
  166.     register array_t    *na;
  167.     register int    n;
  168.  
  169.     if ((na = new_array()) == NULL)
  170.     return NULL;
  171.     if (pushcheck(na, (n = a->a_top - a->a_base)))
  172.     goto fail;
  173.     memcpy((char *)na->a_base, (char *)a->a_base, n * sizeof(object_t *));
  174.     na->a_top += n;
  175.     return objof(na);
  176.  
  177. fail:
  178.     loose(na);
  179.     return NULL;
  180. }
  181.  
  182. STATIC long
  183. hash_array(a)
  184. register array_t    *a;
  185. {
  186.     register int    i;
  187.     long        h;
  188.  
  189.     h = i = a->a_top - a->a_base;
  190.     while (--i >= 0)
  191.     h += (long)a->a_base[i];
  192.     return h;
  193. }
  194.  
  195. STATIC int
  196. assign_array(a, k, v)
  197. register array_t    *a;
  198. object_t        *k;
  199. object_t        *v;
  200. {
  201.     register int    i;
  202.  
  203.     if (!isint(k))
  204.     return assign_simple(objof(a), k, v);
  205.     i = intof(k)->i_value;
  206.     if (arrayprobe(a, i))
  207.     return 1;
  208.     a->a_base[i] = v;
  209.     return 0;
  210. }
  211.  
  212. STATIC object_t *
  213. fetch_array(a, k)
  214. register array_t    *a;
  215. object_t        *k;
  216. {
  217.     register int    i;
  218.  
  219.     if (!isint(k))
  220.     return fetch_simple(objof(a), k);
  221.     if ((i = intof(k)->i_value) >= 0 && i < a->a_top - a->a_base)
  222.     return a->a_base[i];
  223.     return objof(&o_null);
  224. }
  225.  
  226. /*
  227.  * mark any any... => array (os)
  228.  */
  229. STATIC int
  230. op_offsq()
  231. {
  232.     register array_t    *a;
  233.     register int    i;
  234.  
  235.     for (i = 1; os->a_top - i > os->a_base; ++i)
  236.     {
  237.     if (o_top[-i] == objof(&o_mark))
  238.         break;
  239.     }
  240.     if (o_top[-i] != objof(&o_mark))
  241.     return badindex();
  242.     --i;
  243.     if ((a = new_array()) == NULL || pushcheck(a, i))
  244.     return 1;
  245.     memcpy((char *)a->a_base, (char *)&o_top[-i], i * sizeof(object_t *));
  246.     a->a_top += i;
  247.     o_top -= i;
  248.     o_top[-1] = objof(a);
  249.     loose(a);
  250.     --x_top;
  251.     return 0;
  252. }
  253.  
  254. /*
  255.  * obj => array 0 (the array contains the obj)
  256.  */
  257. STATIC int
  258. op_mklvalue()
  259. {
  260.     array_t    *a;
  261.  
  262.     if ((a = new_array()) == NULL)
  263.     return 1;
  264.     *a->a_top++ = o_top[-1];
  265.     o_top[-1] = objof(a);
  266.     *o_top++ = objof(o_zero);
  267.     loose(a);
  268.     --x_top;
  269.     return 0;
  270. }
  271.  
  272. type_t    array_type =
  273. {
  274.     mark_array,
  275.     free_array,
  276.     hash_array,
  277.     cmp_array,
  278.     copy_array,
  279.     assign_array,
  280.     fetch_array,
  281.     "array"
  282. };
  283.  
  284. op_t    o_offsq        = {OBJ(TC_OP, op_type), op_offsq};
  285. op_t    o_mklvalue    = {OBJ(TC_OP, op_type), op_mklvalue};
  286.